Attribute VB_Name = "modStartup" ' Copyright © 1996-2003, Giddings & Lewis Option Explicit Private Const DEBUG_PARAMETER = "/DEBUG" Private Const REG_KEY = "SOFTWARE\SheffieldMeasurement\Common" Private Const REG_ASSISTANT = "PartAssistantProgID" ' Soft Probe Deflection Constants Public Const DEFLECTION_STATUS_UNDER = 0 Public Const DEFLECTION_STATUS_OK = 1 Public Const DEFLECTION_STATUS_OVER = 2 ' Local Variables Private objControl As FormControl ' Part Program Globals Global objAssist As Object Global objCtx As Object Global objData As Object ' Q-Data Globals Global g_sFileName As String Global g_sModelName As String Global g_sPieceName As String ' DMIS Object Private Dmis As Object Private bIsDmisMN As Boolean ' Internal processing variables Private colCommands As New Collection Private sBlockName As String 'Initialize to "" Private bPartial As Boolean 'TRUE -> partial run Private bExecute As Boolean 'TRUE -> skip file type is 'EXECUTE' Private bSkipSeq As Boolean 'TRUE -> in skip block Private bSkipNormal As Boolean 'TRUE -> skip normal code in block Private lstSkpBlks() As String Private nSkpBlkCnt As Integer Private bInUse As Boolean ' For OFI/FLB Migration Private DegToRad As Double ' = 0.017453293 Private RadToDeg As Double ' = 57.29577951 ' Compatibility Variables Global PI As Double ' Win32 declarations Private Const ERROR_SUCCESS = 0& Private Const HKEY_LOCAL_MACHINE = &H80000002 Private Const READ_CONTROL = &H20000 Private Const SYNCHRONIZE = &H100000 Private Const KEY_QUERY_VALUE = &H1 Private Const KEY_READ = ((READ_CONTROL Or KEY_QUERY_VALUE) And (Not SYNCHRONIZE)) Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value. Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long Private iFF_RequestType As Integer Private oFF_Monitor As Object Public vFF_CADPts As Variant Public vFF_FeatureNames As Variant Public dFF_SyncXlation(2) As Double 'Synchronization X,Y,Z translation (0,1,2) Public dFF_SyncRotation(8) As Double 'Synchronization rotation matrix a00,a01,a02,a10,a11,a12,a20,a21,a22 (0,1,...8) Public iFF_SyncDirection As Integer '0==Part to Model, 1==Model to Part Public dFF_AnalysisXlation(2) As Double 'Analysis X,Y,Z translation (0,1,2) Public dFF_AnalysisRotation(8) As Double 'Analysis rotation matrix a00,a01,a02,a10,a11,a12,a20,a21,a22 (0,1,...8) Public iFF_AnalysisDirection As Integer '0==Part to Model, 1==Model to Part Public iFF_OutputBitmap As Integer Public iFF_AnalysisType As Integer Public sFF_Model As String 'The model that is currently open if any Public sFF_BitmapFile As String 'filename of bitmap output after analysis Public sFF_SummaryDataFile As String 'filename of summary data file output after analysis Public Sub Startup() Dim lTickTimeout As Long Dim sAssistProgId As String Dim sError As String Dim objContext As Object Dim sStartup As String Dim nPos As Integer Dim sTemp As String Dim sPIF As String Dim lEvent As Long On Error GoTo errTrap ' Initialize useful information. The agent name is the product ' name as stored in the Product name and the '.Agent'. sStartup = "Part Program Startup" PI = 4 * Atn(1) '3.14159265358979 RadToDeg = 180 / PI DegToRad = PI / 180 sPIF = App.Path & "\partinfo.ini" bInUse = False ' Create the assistant object. If the program is running in debug mode ' then connect the assistant in debug mode. First, we have to find the ' COM ProgID of the assistant class and then we create an instance of ' this object. sAssistProgId = RegistryRead(REG_KEY, REG_ASSISTANT) If sAssistProgId = "" Then MsgBox "Unable to locate the part assistant key in the registry.", vbCritical, sStartup End End If Set objAssist = CreateObject(sAssistProgId) If InStr(Command$, DEBUG_PARAMETER) <> 0 Then objAssist.DebugMode = True ' Signal the assistant to connect to the context server, then wait for it ' to finish connecting. objAssist.Connect App.Path & "\partinfo.ini" lTickTimeout = GetTickCount() + 60000 ' Wiat for one minute While objAssist.IsConnecting If GetTickCount > lTickTimeout Then MsgBox "Timeout waiting for Assistant to connect", vbCritical, sStartup objAssist.Disconnect Set objAssist = Nothing End End If Wait 100 Wend ' Make sure assistant is alive. It is possible to complete the ' connection without having really started. If Not objAssist.IsAlive(lEvent) Then MsgBox "Assistant failed to start", vbCritical, sStartup Shutdown End If ' Save the context object and create an object to access ' the MLB core data Set objCtx = objAssist.Context Set objData = CreateObject("MlbCoreData.MlbCoreData") If Not objData.Initialize(objCtx.CommonDataProcess, objCtx.CommonDataHandle) Then MsgBox "Failed to initialize common data area.", vbCritical, sStartup Shutdown End If 'create and initialize the FormFit data return monitor Set oFF_Monitor = CreateObject("FFData.Handler") oFF_Monitor.MachineName = MachineName oFF_Monitor.Initialize objCtx ' Initialize skip-block data items sBlockName = "" bSkipSeq = False bSkipNormal = True nSkpBlkCnt = 0 ' Get the skip block process request from the program information file (if any) objCtx.ProgramInformationFile = sPIF sTemp = UCase$(ProfileRead(sPIF, "Skip", "PartialRun")) If (sTemp = "TRUE") Or (sTemp = "1") Then sTemp = ProfileRead(sPIF, "Skip", "SkipFile") If ReadSkipFile(sTemp) Then bPartial = True Else bPartial = False End If Else bPartial = False bExecute = False End If ' Success Exit Sub errTrap: MsgBox Err.Description, vbOK Or vbExclamation Shutdown Exit Sub End Sub Public Sub Shutdown() 'rjs000331:On Error modified : Report/PrintMode may not be in pif On Error GoTo Continu If CInt(ProfileRead(objCtx.ProgramInformationFile, "Report", "PrintMode")) <> 0 Then MLString "ID !P" End If Continu: On Error Resume Next CompleteSending Set objCtx = Nothing Set objData = Nothing If (Not oFF_Monitor Is Nothing) Then oFF_Monitor.Terminate Set oFF_Monitor = Nothing objAssist.Disconnect Set objAssist = Nothing End End Sub Public Sub CompleteSending() On Error GoTo errTrap While objAssist.IsSending DoEvents Wait 1 'ermJr980820:Added for issue #495; more delay may be needed for some systems Wend Exit Sub errTrap: Exit Sub End Sub Public Sub AddCommand(sCmd As String) Dim iPos As Integer, iAtPos As Integer Dim s As String s = sCmd iPos = 1 iPos = InStr(1, s, ";") Do While iPos > 0 iAtPos = InStr(1, s, "@") If (iAtPos > 0 And iPos > iAtPos) Then iAtPos = InStr(iAtPos + 1, s, "@") If (iAtPos = 0) Then Exit Do iPos = InStr(iAtPos, s, ";") If (iPos = 0) Then Exit Do End If If iPos > 1 Then AddSingleCommand Left$(s, iPos - 1) End If s = Right$(s, Len(s) - iPos) iPos = InStr(1, s, ";") Loop If Len(s) > 0 Then AddSingleCommand s End Sub Private Sub AddSingleCommand(sCmd As String) Dim sFcs As String, sArg As String Dim nPos As Integer Dim bFound As Boolean Dim v As Variant Dim iPos As Integer Dim s As String ' Extract the FCS command code. sArg = "" nPos = InStr(sCmd, " ") If (nPos = 0) Then sFcs = UCase(sCmd) Else sFcs = UCase(Left(sCmd, nPos - 1)) sArg = UCase(Right(sCmd, Len(sCmd) - nPos)) End If ' Check to see if the command is a HOME command. If ' it is then get the expansion from the current machine ' and send those commands. If (sFcs = "HO" Or sFcs = "HOME") Then v = objCtx.MachineProperty("HOMECOMMAND") If IsNull(v) Then Exit Sub s = CStr(v) iPos = InStr(1, s, ";") While iPos > 0 If iPos > 1 Then colCommands.Add Left$(s, iPos - 1) s = Right$(s, Len(s) - iPos) iPos = InStr(1, s, ";") Wend If Len(s) > 0 Then colCommands.Add s Exit Sub End If ' Allow the user to set the halt on error condition. If (sFcs = "ER" Or sFcs = "ERRHLT") Then If sArg = "NO" Then objAssist.HandleError = False Exit Sub End If If sArg = "YES" Then objAssist.HandleError = True Exit Sub End If DisplayFcsError sCmd, -21 Exit Sub End If ' Handle all of the skip block processing commands. If (sFcs = "BB" Or sFcs = "BEGBLK") Then If (sArg = "") Then DisplayFcsError sCmd, -21 Exit Sub End If If (sBlockName <> "") Then DisplayFcsError sCmd, -14 'Nested block <<<<<<<< Exit Sub End If If (Len(sArg) > 10) Then DisplayFcsError sCmd, -21 Exit Sub End If sBlockName = sArg bSkipSeq = False bFound = SearchForBlockId(sBlockName) '<<<<<<<<<<<<< If ((bFound And Not bExecute) Or (Not bFound And bExecute)) Then bSkipNormal = True colCommands.Add "S1" Else bSkipNormal = False End If Exit Sub End If If (sFcs = "BQ" Or sFcs = "BEGSSEQ") Then If (sArg <> "") Then DisplayFcsError sCmd, -21 Exit Sub End If If (sBlockName = "") Then DisplayFcsError sCmd, -15 'Outside of block<<<<< Exit Sub End If If (bSkipSeq) Then DisplayFcsError sCmd, -16 'Nested skip sequence< Exit Sub End If bSkipSeq = True colCommands.Add IIf(bSkipNormal, "S0", "S1") Exit Sub End If If (sFcs = "EB" Or sFcs = "ENDBLK") Then If (sArg <> "") Then DisplayFcsError sCmd, -21 Exit Sub End If If (sBlockName = "") Then DisplayFcsError sCmd, -15 'Outside of block<<<< Exit Sub End If sBlockName = "" colCommands.Add "S0" Exit Sub End If If (sFcs = "EQ" Or sFcs = "ENDSSEQ") Then If (sArg <> "") Then DisplayFcsError sCmd, -21 Exit Sub End If If (sBlockName = "" Or Not bSkipSeq) Then DisplayFcsError sCmd, -17 'Outside of block<<<< Exit Sub End If bSkipSeq = False colCommands.Add IIf(bSkipNormal, "S1", "S0") Exit Sub End If 'Add command to command list colCommands.Add sCmd Exit Sub End Sub Public Sub SendCommands() Dim v As Variant Dim i As Integer ' Perform some preliminary checks If colCommands.Count <= 0 Then Exit Sub If bInUse Then MsgBox "Send commands is not reentrant.", vbInformation Exit Sub End If ' Set error trapping and in use flag On Error GoTo errTrap bInUse = True ' Copy commands to the variant to send to the context ReDim v(0 To colCommands.Count - 1) For i = 0 To colCommands.Count - 1 v(i) = colCommands.Item(i + 1) Next i ' Clear the command queue While colCommands.Count > 0 colCommands.Remove 1 Wend ' Post the command to the context While Not objAssist.CommandPostImmediate(v) Wait 100 ' may generate events Wend ' Wait for the command to complete CompleteSending bInUse = False Exit Sub errTrap: bInUse = False ' MsgBox Err.Description, vbOK Or vbExclamation Shutdown Exit Sub End Sub Public Sub BSetup(N As Integer) End Sub Public Sub Endprogram() Shutdown End Sub Public Sub MLString(sCmd As String) AddCommand sCmd SendCommands If ((UCase(sCmd) = "IN") Or (UCase(sCmd) = "ME")) Then FF_MiscData End Sub Public Sub Opwait(sPrompt As String) If (sPrompt <> "") Then MLString IIf(Left(sPrompt, 1) <> "@", "OW @" & sPrompt & "@", "OW " & sPrompt) Else MLString "OW" End If End Sub Public Sub ReadPosition(sArg As String) AddSingleCommand "IM" AddSingleCommand "SF " & sArg SendCommands End Sub Public Sub Park(sArg As String) Dim dX As Double, dY As Double, dZ As Double Dim dMax As Double MLString "TU" dX = objData.S7 dY = objData.s8 dZ = objData.s10 dMax = IIf(dX > dY, dX, dY) If dZ > dMax Then dMax = dZ If objData.Inches Then If dMax > 0.02 Then AddSingleCommand "TU .02,.02,.02" Else If dMax > 0.5 Then AddSingleCommand "TU 0.5,0.5,0.5" End If ' AddSingleCommand "PK " & sArg ' MLString "PK " & sArg AddSingleCommand "WM XI0" SendCommands Sleep 1 MLString "TU " & Trim(str(dX)) & "," & Trim(str(dY)) & "," & Trim(str(dZ)) End Sub Public Sub Manual() MLString "MN" End Sub Public Sub ServoOff() MLString "OS" End Sub Public Sub BeginBlock(sArg As String) MLString "BB " & sArg End Sub Public Sub EndBlock() MLString "EB" End Sub Public Sub BeginSkip() MLString "BQ" End Sub Public Sub EndSkip() MLString "EQ" End Sub Public Sub CalibChanger() MLString "C6" End Sub Public Sub TipFile(sArg As String) MLString "FP " & sArg End Sub Public Sub PlaneXY() MLString "XY" End Sub Public Sub PlaneYZ() MLString "YZ" End Sub Public Sub PlaneZX() MLString "ZX" End Sub Public Sub Level(sArg As String) MLString "LV " & sArg End Sub Public Sub Offset(sArg As String) MLString "EO " & sArg End Sub Public Sub SetXOrigin(sArg As String) MLString "EX " & sArg End Sub Public Sub SetYOrigin(sArg As String) MLString "EY " & sArg End Sub Public Sub SetZOrigin(sArg As String) MLString "EZ " & sArg End Sub Public Sub SetXYZOrigin(sArg As String) MLString "ES " & sArg End Sub Public Sub TransOrigin(sArg As String) MLString "MR " & sArg End Sub Public Sub Rotate(sArg As String) MLString "MO " & sArg End Sub Public Sub SaveDatum(sArg As String) MLString IIf(sArg <> "", "SR " & sArg, "SR") End Sub Public Sub RecallDatum(sArg As String) MLString IIf(sArg <> "", "RR " & sArg, "RR") End Sub Public Sub DeleteDatum(sArg As String) MLString IIf(sArg <> "", "DR " & sArg, "DR") End Sub Public Sub DeleteFeature(sArg As String) MLString IIf(sArg <> "", "DF " & sArg, "DF") End Sub Public Sub SetFormat(sArg As String) MLString "FM " & sArg End Sub Public Sub IdData(sArg As String) MLString IIf(sArg <> "", "ID " & sArg, "ID") End Sub Public Sub CrtData(sArg As String) MLString IIf(sArg <> "", "PM " & sArg, "PM") End Sub Public Sub LogFull() MLString "LF" End Sub Public Sub LogPartial() MLString "LP" End Sub Public Sub Polar() MLString "PF" End Sub Public Sub Cartesian() MLString "RD" End Sub Public Sub ReportOn() MLString "P1" End Sub Public Sub ReportOff() MLString "P0" End Sub Public Sub LogOn() MLString "L1" End Sub Public Sub LogOff() MLString "L0" End Sub Public Sub CsvOn(sArg As String) MLString "C1 " & sArg End Sub Public Sub CsvOff() MLString "C0" End Sub Public Sub Rfs() MLString "RS" End Sub Public Sub Mmc() MLString "MM" End Sub Public Sub Bilateral() MLString "BL" End Sub Public Sub Limit() MLString "LM" End Sub Public Sub TouchSpeed(sArg As String) MLString IIf(sArg <> "", "TD " & sArg, "TD") End Sub Public Sub Speed(sArg As String) MLString IIf(sArg <> "", "SD " & sArg, "SD") End Sub Public Sub Backoff(sArg As String) MLString IIf(sArg <> "", "BO " & sArg, "BO") End Sub Public Sub OverDrive(sArg As String) MLString IIf(sArg <> "", "OD " & sArg, "OD") End Sub Public Sub Clearance(sArg As String) MLString IIf(sArg <> "", "CL " & sArg, "CL") End Sub Public Sub Altitude(sArg As String) MLString IIf(sArg <> "", "AL " & sArg, "AL") End Sub Public Sub TableSpeed(sArg As String) MLString IIf(sArg <> "", "SW " & sArg, "SW") End Sub Public Sub MoveTolerance(sArg As String) MLString IIf(sArg <> "", "TU " & sArg, "TU") End Sub Public Sub Inch() MLString "IN" End Sub Public Sub Metric() MLString "ME" End Sub Public Sub RemeasureOn() MLString "R1" End Sub Public Sub RemeasureOff() MLString "R0" End Sub Public Sub TempComp(sArg As String) MLString IIf(sArg <> "", "IT " & sArg, "IT") End Sub Public Sub TableAngle(sArg As String) MLString "TB " & sArg End Sub Public Sub Move(sArg As String) MLString "AM " & sArg End Sub Public Sub WaitMove(sArg As String) MLString "WM " & sArg End Sub Public Sub Touch(sArg As String) MLString "TC " & sArg End Sub Public Sub VectorTouch(sArg As String) MLString "VT " & sArg End Sub Public Sub MachineScale(sArg As String) MLString "SM " & sArg End Sub Public Sub PartScale(sArg As String) MLString "SP " & sArg End Sub Public Sub TouchTolerance(sArg As String) MLString IIf(sArg <> "", "TV " & sArg, "TV") End Sub Public Sub NewCsv(sArg As String) MLString "NEWCSV " & sArg End Sub Public Sub NewLog(sArg As String) MLString "NEWLOG " & sArg End Sub Public Sub NewRpt() MLString "NEWRPT" End Sub Public Sub Rdcrt(sPrompt As String, sResult As String) MLString IIf(sPrompt <> "", "~2@" & sPrompt & "@", "~2@ @") sResult = objData.s0d End Sub Public Sub RdcrtReal(sPrompt As String, sResult As Double) MLString IIf(sPrompt <> "", "~4@" & sPrompt & "@", "~4@ @") sResult = objData.S7 End Sub Public Sub RdcrtInt(sPrompt As String, sResult As Long) MLString IIf(sPrompt <> "", "~3@" & sPrompt & "@", "~3@ @") sResult = objData.S7 End Sub Public Sub RdcrtYN(sPrompt As String, sResult As String) MLString IIf(sPrompt <> "", "~5@" & sPrompt & "@", "~5@ @") sResult = objData.s0d End Sub Public Sub WrtCRT(s As String, nCR As Integer) If (s = "") Then MLString IIf(nCR = 0, "~1@ " & Chr(13) & "@", "~1@ @") Else MLString IIf(nCR = 0, "~1@ " & s & Chr(13) & "@", "~1@" & s & "@") End If End Sub Public Sub AbortPartPg(N As Integer) MLString "~6 " & str(N) End Sub Public Sub WrtRpt(s As String, nCR As Integer) If (s = "") Then MLString IIf(nCR = 0, "~7@ " & Chr(13) & "@", "~7@ @") Else MLString IIf(nCR = 0, "~7@ " & s & Chr(13) & "@", "~7@" & s & "@") End If End Sub Public Sub WrtRptFile(s As String) MLString "~8 " & s End Sub Public Sub DeleteRefFrame(sArg As String) MLString IIf(sArg <> "", "DR " & sArg, "DR") End Sub Public Sub SaveRefFrame(sArg As String) MLString IIf(sArg <> "", "SR " & sArg, "SR") End Sub Public Sub RecallRefFrame(sArg As String) MLString IIf(sArg <> "", "RR " & sArg, "RR") End Sub Public Function DDEWrite(sApp As String, sTopic As String, sItem As String, sData As String) As Integer If objControl Is Nothing Then Set objControl = New FormControl End If DDEWrite = objControl.DDEWrite(sApp, sTopic, sItem, sData) End Function Public Function DDERead(sApp As String, sTopic As String, sItem As String, sData As String, TimeOut As Single) As Integer If objControl Is Nothing Then Set objControl = New FormControl End If DDERead = objControl.DDERead(sApp, sTopic, sItem, sData, TimeOut) End Function Public Sub Sleep(nSeconds As Integer) Dim lDone As Long lDone = GetTickCount() + (nSeconds * 1000) While GetTickCount() < lDone DoEvents Wend End Sub Private Sub Wait(nMilliSeconds As Long) Dim lDone As Long lDone = GetTickCount() + nMilliSeconds While GetTickCount() < lDone DoEvents Wend End Sub Private Function RegistryRead(sKey As String, sName As String) As String Dim lKeyResult As Long Dim lKey As Long Dim lType As Long Dim sTemp As String Dim lLen As Long Dim iPos As Integer lKey = HKEY_LOCAL_MACHINE If (RegOpenKeyEx(lKey, sKey, 0, KEY_READ, lKeyResult) <> ERROR_SUCCESS) Then RegistryRead = "" Else sTemp = String(256, 0) lLen = 255 If RegQueryValueEx(lKeyResult, sName, 0, lType, sTemp, lLen) <> ERROR_SUCCESS Then RegistryRead = "" Else sTemp = Left$(sTemp, lLen) If Right$(sTemp, 1) = Chr$(0) Then sTemp = Left$(sTemp, Len(sTemp) - 1) End If RegistryRead = sTemp End If RegCloseKey lKeyResult End If Exit Function End Function Function ProfileRead(sIniFileName As String, sSection As String, sKey As String) As String Dim sBuffer As String Dim iSize As Integer Dim iLength As Integer Dim sDefault As String ' Dimension storage for the results and add one for the null terminator iSize = 256 sBuffer = Space$(iSize + 1) ' Set default value (if the key is not found) sDefault = "" ' Call the WinAPI function to read the file iLength = GetPrivateProfileString(sSection, sKey, sDefault, sBuffer, iSize, sIniFileName) ' Return the results ProfileRead = Mid$(sBuffer, 1, iLength) End Function Public Function SearchForBlockId(sBlockName As String) As Boolean Dim i As Integer If bPartial And nSkpBlkCnt > 0 Then For i = 0 To nSkpBlkCnt - 1 If sBlockName = lstSkpBlks(i) Then SearchForBlockId = True Exit Function End If Next i End If SearchForBlockId = False End Function Public Sub DisplayFcsError(sFcs As String, nErr As Integer) colCommands.Add "~E " & str(nErr) & "," & sFcs End Sub Public Property Get Name() As String Name = App.ProductName End Property Public Function ReadSkipFile(sName As String) As Boolean Dim sRecord As String Dim nPos As Integer, nPos1 As Integer On Error GoTo errTrap Open sName For Input As #1 Do While Not EOF(1) Line Input #1, sRecord sRecord = UCase(sRecord) nPos = InStr(sRecord, "!") If (nPos <> 0) Then sRecord = Left(sRecord, nPos - 1) ' Strip trailing spaces and tabs Do While (Right(sRecord, 1) = " " Or Right(sRecord, 1) = Chr(9)) sRecord = Left(sRecord, Len(sRecord) - 1) Loop If (Len(sRecord) > 0) Then Exit Do Loop nPos = InStr(sRecord, "TYPE=EXECUTE") nPos1 = InStr(sRecord, "TYPE=SKIP") If (nPos <> 0) Then bExecute = True If (nPos1 <> 0) Then bExecute = False If (nPos = 0 And nPos1 = 0) Then DisplayFcsError "Init", -11 ReadSkipFile = False Close #1 Exit Function End If Do While Not EOF(1) Line Input #1, sRecord sRecord = UCase(sRecord) nPos = InStr(sRecord, "!") If (nPos <> 0) Then sRecord = Left(sRecord, nPos - 1) ' Strip trailing spaces and tabs Do While (Right(sRecord, 1) = " " Or Right(sRecord, 1) = Chr(9)) sRecord = Left(sRecord, Len(sRecord) - 1) Loop If (Len(sRecord) > 0) Then If (Len(sRecord) > 10) Then DisplayFcsError "Init", -12 ReadSkipFile = False Close #1 Exit Function Else ReDim Preserve lstSkpBlks(nSkpBlkCnt + 1) lstSkpBlks(nSkpBlkCnt) = sRecord nSkpBlkCnt = nSkpBlkCnt + 1 End If End If Loop ReadSkipFile = True Close #1 Exit Function errTrap: DisplayFcsError "Init", -13 ReadSkipFile = False Close #1 End Function Public Sub SoftProbeDeflection(sArg As String) MLString IIf(sArg <> "", "KD " & sArg, "KD") End Sub Public Sub TrackSpeed(sArg As String) MLString IIf(sArg <> "", "KS " & sArg, "KS") End Sub Public Sub TrackMoveZone(sArg As String) MLString IIf(sArg <> "", "KT " & sArg, "KT") End Sub 'ermJr980820:Added for issue #496 'rjs000217:Condition added for issue #667 'rjs000331:On Error added : Report/PrintMode may not be in pif Public Sub FormFeed() On Error GoTo Continu If CInt(ProfileRead(objCtx.ProgramInformationFile, "Report", "PrintMode")) <> 0 Then MLString "ID ~F" End If Continu: End Sub 'ermJr980820:Added for issue #498 Public Sub InsertTextInReport(sArg As String) MLString "ID ~I" & sArg End Sub ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dCosD(dAngleDeg As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleDeg * DegToRad dTemp = Cos(dAngle) dCosD = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dCos(dAngleRad As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleRad dTemp = Cos(dAngle) dCos = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dSinD(dAngleDeg As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleDeg * DegToRad dTemp = Sin(dAngle) dSinD = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dSin(dAngleRad As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleRad dTemp = Sin(dAngle) dSin = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dTanD(dAngleDeg As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleDeg * DegToRad dTemp = Tan(dAngle) dTanD = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dTan(dAngleRad As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleRad dTemp = Tan(dAngle) dTan = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAsnD(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Atn(dRatio / Sqr(-dRatio * dRatio + 1)) dAsnD = RadToDeg * dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAsn(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Atn(dRatio / Sqr(-dRatio * dRatio + 1)) dAsn = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAtnD(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Atn(dRatio) dAtnD = RadToDeg * dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAtn(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Atn(dRatio) dAtn = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAcsD(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Atn(-dRatio / Sqr(-dRatio * dRatio + 1)) + 2 * Atn(1) dAcsD = RadToDeg * dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAcs(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Atn(-dRatio / Sqr(-dRatio * dRatio + 1)) + 2 * Atn(1) dAcs = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dSinHD(dAngleDeg As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleDeg * DegToRad dTemp = (Exp(dAngle) - Exp(-dAngle)) / 2 dSinHD = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dSinH(dAngleRad As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleRad dTemp = (Exp(dAngle) - Exp(-dAngle)) / 2 dSinH = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dCosHD(dAngleDeg As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleDeg * DegToRad dTemp = (Exp(dAngle) + Exp(-dAngle)) / 2 dCosHD = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dCosH(dAngleRad As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleRad dTemp = (Exp(dAngle) + Exp(-dAngle)) / 2 dCosH = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dTanHD(dAngleDeg As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleDeg * DegToRad dTemp = (Exp(dAngle) - Exp(-dAngle)) / (Exp(dAngle) + Exp(-dAngle)) dTanHD = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dTanH(dAngleRad As Double) As Double Dim dAngle As Double Dim dTemp As Double On Error GoTo errTrap dAngle = dAngleRad dTemp = (Exp(dAngle) - Exp(-dAngle)) / (Exp(dAngle) + Exp(-dAngle)) dTanH = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAsnHD(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Log(dRatio + Sqr(dRatio * dRatio + 1)) dAsnHD = dTemp * RadToDeg Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAsnH(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Log(dRatio + Sqr(dRatio * dRatio + 1)) dAsnH = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAcsHD(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Log(dRatio + Sqr(dRatio * dRatio - 1)) dAcsHD = dTemp * RadToDeg Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAcsH(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Log(dRatio + Sqr(dRatio * dRatio - 1)) dAcsH = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAtnHD(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Log((1 + dRatio) / (1 - dRatio)) / 2 dAtnHD = dTemp * RadToDeg Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function ' rwh 981009: Added for OFI/FLB Trig Migration Support Public Function dAtnH(dRatio As Double) As Double Dim dTemp As Double On Error GoTo errTrap dTemp = Log((1 + dRatio) / (1 - dRatio)) / 2 dAtnH = dTemp Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source Exit Function End Function Public Function ApplicationEXEName() As String 'ermJr000217:added for issue #555 On Error GoTo errTrap ApplicationEXEName = App.EXEName Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source ApplicationEXEName = "" End Function Public Function ApplicationTitle() As String 'ermJr000217:added for issue #555 On Error GoTo errTrap ApplicationTitle = App.Title Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source ApplicationTitle = "" End Function Public Function DBKeyValue(DBLabel As String) As String 'ermJr000217:added for issue #555 On Error GoTo errTrap DBKeyValue = ProfileRead(App.Path & "\partinfo.ini", "Report", DBLabel) Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source DBKeyValue = "" End Function Public Function LibraryName() As String 'ermJr000217:added for issue #555 On Error GoTo errTrap LibraryName = ProfileRead(App.Path & "\partinfo.ini", "Part", "LibraryName") Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source LibraryName = "" End Function Public Function MachineName() As String 'ermJr000217:added for issue #555 On Error GoTo errTrap MachineName = objCtx.Name Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source MachineName = "" End Function Public Function MMTempDir() As String On Error GoTo errTrap MMTempDir = RegistryRead("Software\SheffieldMeasurement\MeasureMax\Settings\", "TempDirectory") Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source MMTempDir = "C:\Temp" End Function Public Function UserName() As String 'ermJr000217:added for issue #555 On Error GoTo errTrap UserName = RegistryRead("Software\SheffieldMeasurement\" & objCtx.userkey, "Name") Exit Function errTrap: MsgBox Err.Number & ": " & Err.Description, vbExclamation + vbOKOnly, Err.Source UserName = "" End Function ' ' DMIS Statements ' Public Sub DmsACLRAT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsACLRAT vArgList End Sub Public Sub DmsALGDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsALFDEF vArgList End Sub Public Function DmsASSIGN(varname As Variant, expr As Variant) As Variant Dim vArgList As Variant ReDim vArgList(0 To 1) vArgList(0) = varname vArgList(1) = expr DmsASSIGN = Dmis.DmsASSIGN(vArgList) End Function Public Sub DmsBADTST(ByVal sArg As String) ' Not supported in this release End Sub Public Sub DmsBOUND(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsBOUND vArgList End Sub Public Sub DmsCALIB(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCALIB vArgList End Sub Public Sub DmsCLMPID(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsCLMPID vArgList End Sub Public Sub DmsCLMPSN(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsCLMPSN vArgList End Sub Public Sub DmsCLOSE(ParamArray vArg() As Variant) ' End Sub Public Sub DmsCONST(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCONST vArgList End Sub Public Sub DmsCRGDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCRGDEF vArgList End Sub Public Sub DmsCRMODE(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCRMODE vArgList End Sub Public Sub DmsCROSCL(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCROSCL vArgList End Sub Public Sub DmsCRSLCT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCRSLCT vArgList End Sub Public Sub DmsCUTCOM(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCUTCOM vArgList End Sub Public Sub DmsCZONE(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCZONE vArgList End Sub Public Sub DmsCZSLCT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsCZSLCT vArgList End Sub Public Sub DmsDATDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsDATDEF vArgList End Sub Public Sub DmsDATSET(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsDATSET vArgList End Sub Public Sub DmsDECPL(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsDECPL vArgList End Sub Public Sub DmsDELETE(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsDELETE vArgList End Sub Public Sub DmsDEVICE(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsDEVICE vArgList End Sub Public Sub DmsDISPLY(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsDISPLY vArgList End Sub Public Sub DmsDMEHW(ByVal sArg As String) ' End Sub Public Sub DmsDMEID(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsDMEID vArgList End Sub Public Sub DmsDMESW(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsDMESW vArgList End Sub Public Sub DmsDMESWI(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsDMESWI vArgList End Sub Public Sub DmsDMESWV(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsDMESWV vArgList End Sub Public Sub DmsDMIS(ByVal sArg As String) Dmis.DmsDMIS sArg End Sub Public Sub DmsDMISMD(ByVal sArg As String) bIsDmisMN = False Dmis.DmsDMISMD sArg End Sub Public Sub DmsDMISMN(sArg As String, Optional vArg As Variant) bIsDmisMN = True MLString "IL" ' Always Initialize Library If (Dmis Is Nothing) Then Set Dmis = CreateObject("DmisHandler.GLDmisHandler") Dmis.Initialize objAssist, objData, Name End If If IsMissing(vArg) Then Dmis.DmsDMISMN sArg Else Dmis.DmsDMISMN sArg, vArg End If End Sub Public Sub DmsENDFIL() Dmis.DmsENDFIL If bIsDmisMN Then Dmis.Terminate Set Dmis = Nothing End If End Sub Public Sub DmsENDGO() Dmis.DmsENDGO End Sub Public Sub DmsENDMES() Dmis.DmsENDMES End Sub Public Sub DmsERROR(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsERROR vArgList End Sub Public Sub DmsEVAL(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsEVAL vArgList End Sub Public Sub DmsEXTFIL(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsEXTFIL vArgList End Sub Public Sub DmsFEAT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsFEAT vArgList End Sub Public Sub DmsFEDRAT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsFEDRAT vArgList End Sub Public Sub DmsFILDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsFILDEF vArgList End Sub Public Sub DmsFILNAM(ByVal sArg As String, Optional vArg As Variant) If IsMissing(vArg) Then Dmis.DmsFILNAM sArg Else Dmis.DmsFILNAM sArg, vArg End If End Sub Public Sub DmsFINPOS(ByVal sArg As String) Dmis.DmsFINPOS sArg End Sub Public Sub DmsFIXTID(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsFIXTID vArgList End Sub Public Sub DmsFIXTSN(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsFIXTSN vArgList End Sub Public Sub DmsFROM(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsFROM vArgList End Sub Public Sub DmsGECOMP(ByVal sArg As String) ' Not supported in this release End Sub Public Sub DmsGEOALG(ParamArray vArg() As Variant) ' Not supported in this release End Sub Public Sub DmsGEOM(ParamArray vArg() As Variant) ' Not supported in this release End Sub Public Sub DmsGOHOME() Dmis.DmsGOHOME End Sub Public Sub DmsGOTARG(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsGOTARG vArgList End Sub Public Sub DmsGOTO(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsGOTO vArgList End Sub Public Sub DmsINCLUD(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsINCLUD vArgList End Sub Public Sub DmsLITDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsLITDEF vArgList End Sub Public Sub DmsLOCATE(ParamArray vArg() As Variant) ' Not supported in this release End Sub Public Sub DmsLOTID(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsLOTID vArgList End Sub Public Sub DmsMATDEF(ParamArray vArg() As Variant) ' Not supported in this release End Sub Public Sub DmsMEAS(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsMEAS vArgList End Sub Public Sub DmsMFGDEV(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsMFGDEV vArgList End Sub Public Sub DmsMODE(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsMODE vArgList End Sub Public Function DmsOBTAIN(ParamArray vArg() As Variant) As Variant Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll DmsOBTAIN = Dmis.DmsOBTAIN(vArgList) End Function Public Sub DmsOPEN(ParamArray vArg() As Variant) ' End Sub Public Sub DmsOPERID(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsOPERID vArgList End Sub Public Sub DmsOUTPUT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsOUTPUT vArgList End Sub Public Sub DmsPARTID(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsPARTID vArgList End Sub Public Sub DmsPARTRV(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsPARTRV vArgList End Sub Public Sub DmsPARTSN(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsPARTSN vArgList End Sub Public Sub DmsPLANID(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsPLANID vArgList End Sub Public Sub DmsPRCOMP(ByVal sArg As String) Dmis.DmsPRCOMP sArg End Sub Public Sub DmsPREVOP(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsPREVOP vArgList End Sub Public Sub DmsPROCID(ByVal sLabel As String, ByVal sText As String) Dim vArgList As Variant ReDim vArgList(0 To 1) As Variant vArgList(0) = sLabel vArgList(1) = sText Dmis.DmsPROCID vArgList End Sub Public Sub DmsPROMPT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsPROMPT vArgList End Sub Public Sub DmsPSTHRU(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsPSTHRU vArgList End Sub Public Sub DmsPTBUFF(ByVal sArg As String) Dmis.DmsPTBUFF sArg End Sub Public Sub DmsPTMEAS(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsPTMEAS vArgList End Sub Public Sub DmsQISDEF(ParamArray vArg() As Variant) ' Not supported in this release End Sub Public Sub DmsRAPID(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsRAPID vArgList End Sub Public Sub DmsREAD(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsREAD vArgList End Sub Public Sub DmsRECALL(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsRECALL vArgList End Sub Public Sub DmsREPORT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsREPORT vArgList End Sub Public Sub DmsRESUME(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsRESUME vArgList End Sub Public Sub DmsRMEAS(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsRMEAS vArgList End Sub Public Sub DmsROTAB(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsROTAB vArgList End Sub Public Sub DmsROTATE(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsROTATE vArgList End Sub Public Sub DmsROTDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsROTDEF vArgList End Sub Public Sub DmsROTSET(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsROTSET vArgList End Sub Public Sub DmsSAVE(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSAVE vArgList End Sub Public Sub DmsSCAN(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSCAN vArgList End Sub Public Sub DmsSCNMOD(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSCNMOD vArgList End Sub Public Sub DmsSCNPLN(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSCNPLN vArgList End Sub Public Sub DmsSCNSET(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSCNSET vArgList End Sub Public Sub DmsSNSDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSNSDEF vArgList End Sub Public Sub DmsSNSET(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSNSET vArgList End Sub Public Sub DmsSNSLCT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSNSLCT vArgList End Sub Public Sub DmsSNSMNT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsSNSMNT vArgList End Sub Public Sub DmsTECOMP(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsTECOMP vArgList End Sub Public Sub DmsTEXT(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsTEXT vArgList End Sub Public Sub DmsTHLDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsTHLDEF vArgList End Sub Public Sub DmsTOL(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsTOL vArgList End Sub Public Sub DmsTOOLDF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsTOOLDF vArgList End Sub Public Sub DmsTRANS(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsTRANS vArgList End Sub Public Sub DmsUNITS(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsUNITS vArgList End Sub Public Function DmsVALUE(ParamArray vArg() As Variant) As Variant Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll DmsVALUE = Dmis.DmsVALUE(vArgList) End Function Public Sub DmsVFORM(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsVFORM vArgList End Sub Public Sub DmsWINDEF(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsWINDEF vArgList End Sub Public Sub DmsWKPLAN(sArg As String) Dmis.DmsWKPLAN sArg End Sub Public Sub DmsWRITE(ParamArray vArg() As Variant) Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(vArg) ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = vArg(ll) Next ll Dmis.DmsWRITE vArgList End Sub Public Sub DmsXTERN() ' Not supported in this release End Sub Public Sub DmsXTRACT() ' Not supported in this release End Sub ' ' DMIS labels ' Public Function DmsCC(ByVal sArg As String) As String DmsCC = "CC(" & sArg & ")" End Function Public Function DmsCI(ByVal sArg As String) As String DmsCI = "CI(" & sArg & ")" End Function Public Function DmsCS(ByVal sArg As String) As String DmsCS = "CS(" & sArg & ")" End Function Public Function DmsCR(ByVal sArg As String) As String DmsCR = "CR(" & sArg & ")" End Function Public Function DmsD(ByVal sArg As String) As String DmsD = "D(" & sArg & ")" End Function Public Function DmsDA(ByVal sArg As String) As String DmsDA = "DA(" & sArg & ")" End Function Public Function DmsDAT(ByVal sArg As String) As String DmsDAT = "DAT(" & sArg & ")" End Function Public Function DmsDI(ByVal sArg As String) As String DmsDI = "DI(" & sArg & ")" End Function Public Function DmsDID(ByVal sArg As String) As String DmsDID = "DID(" & sArg & ")" End Function Public Function DmsDS(ByVal sArg As String) As String DmsDS = "DS(" & sArg & ")" End Function Public Function DmsDV(ByVal sArg As String) As String DmsDV = "DV(" & sArg & ")" End Function Public Function DmsF(ByVal sArg As String, ParamArray vPtBuff() As Variant) As String Select Case UBound(vPtBuff) Case -1 DmsF = "F(" & sArg & ")" Case 0 DmsF = "F(" & sArg & ")[" & vPtBuff(0) & "]" Case 1 DmsF = "F(" & sArg & ")[" & vPtBuff(0) & "," & vPtBuff(1) & "]" Case Else End Select End Function Public Function DmsFA(ByVal sArg As String, ParamArray vPtBuff() As Variant) As String Select Case UBound(vPtBuff) Case -1 DmsFA = "FA(" & sArg & ")" Case 0 DmsFA = "FA(" & sArg & ")[" & vPtBuff(0) & "]" Case 1 DmsFA = "FA(" & sArg & ")[" & vPtBuff(0) & "," & vPtBuff(1) & "]" Case Else End Select End Function Public Function DmsFI(ByVal sArg As String) As String DmsFI = "FI(" & sArg & ")" End Function Public Function DmsFS(ByVal sArg As String) As String DmsFS = "FS(" & sArg & ")" End Function Public Function DmsG(ByVal sArg As String) As String DmsG = "G(" & sArg & ")" End Function Public Function DmsLI(ByVal sArg As String) As String DmsLI = "LI(" & sArg & ")" End Function Public Function DmsMA(ByVal sArg As String) As String DmsMA = "MA(" & sArg & ")" End Function Public Function DmsMD(ByVal sArg As String) As String DmsMD = "MD(" & sArg & ")" End Function Public Function DmsOP(ByVal sArg As String) As String DmsOP = "OP(" & sArg & ")" End Function Public Function DmsPC(ByVal sArg As String) As String DmsPC = "PC(" & sArg & ")" End Function Public Function DmsPL(ByVal sArg As String) As String DmsPL = "PL(" & sArg & ")" End Function Public Function DmsPN(ByVal sArg As String) As String DmsPN = "PN(" & sArg & ")" End Function Public Function DmsPR(ByVal sArg As String) As String DmsPR = "PR(" & sArg & ")" End Function Public Function DmsPS(ByVal sArg As String) As String DmsPS = "PS(" & sArg & ")" End Function Public Function DmsPV(ByVal sArg As String) As String DmsPV = "PV(" & sArg & ")" End Function Public Function DmsR(ByVal sArg As String) As String DmsR = "R(" & sArg & ")" End Function Public Function DmsRT(ByVal sArg As String) As String DmsRT = "RT(" & sArg & ")" End Function Public Function DmsS(ByVal sArg As String) As String DmsS = "S(" & sArg & ")" End Function Public Function DmsSA(ByVal sArg As String) As String DmsSA = "SA(" & sArg & ")" End Function Public Function DmsT(ByVal sArg As String) As String DmsT = "T(" & sArg & ")" End Function Public Function DmsTA(ByVal sArg As String) As String DmsTA = "TA(" & sArg & ")" End Function Public Function DmsTH(ByVal sArg As String) As String DmsTH = "TH(" & sArg & ")" End Function Public Function DmsTL(ByVal sArg As String) As String DmsTL = "TL(" & sArg & ")" End Function Public Function DmsV(ByVal sArg As String) As String DmsV = "V(" & sArg & ")" End Function Public Function DmsVA(ByVal sArg As String) As String DmsVA = "VA(" & sArg & ")" End Function Public Function DmsVF(ByVal sArg As String) As String DmsVF = "VF(" & sArg & ")" End Function Public Function DmsVL(ByVal sArg As String) As String DmsVL = "VL(" & sArg & ")" End Function Public Function DmsVW(ByVal sArg As String) As String DmsVW = "VW(" & sArg & ")" End Function ' ' Dmis HLL ' Public Function DmsABS(ByVal Number As Variant) As Variant DmsABS = Dmis.DmsABS(Number) End Function Public Function DmsACOS(ByVal Number As Variant) As Variant DmsACOS = Dmis.DmsACOS(Number) End Function Public Function DmsASIN(ByVal Number As Variant) As Variant DmsASIN = Dmis.DmsASIN(Number) End Function Public Function DmsATAN(ByVal Number As Variant) As Variant DmsATAN = Dmis.DmsATAN(Number) End Function Public Function DmsATAN2(ByVal x As Variant, ByVal y As Variant) As Variant DmsATAN2 = Dmis.DmsATAN2(x, y) End Function Public Function DmsCOS(ByVal Number As Variant) As Variant DmsCOS = Dmis.DmsCOS(Number) End Function Public Function DmsDBLE(ByVal Number As Variant) As Variant DmsDBLE = Dmis.DmsDBLE(Number) End Function Public Function DmsDTOR(ByVal Number As Variant) As Variant DmsDTOR = Dmis.DmsDTOR(Number) End Function Public Function DmsEXP(ByVal Number As Variant) As Variant DmsEXP = Dmis.DmsEXP(Number) End Function Public Function DmsINT(ByVal Number As Variant) As Integer DmsINT = Dmis.DmsINT(Number) End Function Public Function DmsLN(ByVal Number As Variant) As Variant DmsLN = Dmis.DmsLN(Number) End Function Public Function DmsLOG(ByVal Number As Variant) As Variant DmsLOG = Dmis.DmsLOG(Number) End Function Public Function DmsMN(ByVal X0 As Variant, ByVal X1 As Variant, ParamArray Xn() As Variant) As Variant Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(Xn) If lUBound > -1 Then ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = Xn(ll) Next ll DmsMN = Dmis.DmsMN(X0, X1, vArgList) Else DmsMN = Dmis.DmsMN(X0, X1) End If End Function Public Function DmsMOD(ByVal x As Variant, ByVal y As Variant) As Variant DmsMOD = Dmis.DmsMOD(x, y) End Function Public Function DmsMX(ByVal X0 As Variant, ByVal X1 As Variant, ParamArray Xn() As Variant) As Variant Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(Xn) If lUBound > -1 Then ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = Xn(ll) Next ll DmsMX = Dmis.DmsMX(X0, X1, vArgList) Else DmsMX = Dmis.DmsMN(X0, X1) End If End Function Public Function DmsNINT(ByVal Number As Variant) As Integer DmsNINT = Dmis.DmsNINT(Number) End Function Public Function DmsRL(ByVal Number As Variant) As Single DmsRL = Dmis.DmsRL(Number) End Function Public Function DmsRTOD(ByVal Number As Variant) As Variant DmsRTOD = Dmis.DmsRTOD(Number) End Function Public Function DmsSIGN(ByVal x As Variant, ByVal y As Variant) As Variant DmsSIGN = Dmis.DmsSIGN(x, y) End Function Public Function DmsSQRT(ByVal Number As Variant) As Variant DmsSQRT = Dmis.DmsSQRT(Number) End Function Public Function DmsTAN(ByVal Number As Variant) As Variant DmsTAN = Dmis.DmsTAN(Number) End Function Public Function DmsCHR(ByVal CharCode As Variant) As String DmsCHR = Dmis.DmsCHR(CharCode) End Function Public Function DmsCONCAT(ByVal str0 As String, ByVal str1 As String, ParamArray strn() As Variant) As String Dim ll As Long Dim lUBound As Long Dim vArgList As Variant lUBound = UBound(strn) If lUBound > -1 Then ReDim vArgList(0 To lUBound) For ll = 0 To lUBound vArgList(ll) = strn(ll) Next ll DmsCONCAT = Dmis.DmsCONCAT(str0, str1, vArgList) Else DmsCONCAT = Dmis.DmsCONCAT(str0, str1) End If End Function Public Function DmsELEMNT(ByVal vElementNo As Variant, ByVal sDelimiter As String, ByVal sString As String) As Variant DmsELEMNT = Dmis.DmsELEMNT(vElementNo, sDelimiter, sString) End Function Public Function DmsINDX(ByVal str As String, ByVal sstr As String) As Integer DmsINDX = Dmis.DmsINDX(str, sstr) End Function Public Function DmsLEN(ByVal str As String) As Integer DmsLEN = Dmis.DmsLEN(str) End Function Public Function DmsORD(ByVal vArg As Variant) As Integer DmsORD = Dmis.DmsORD(vArg) End Function Public Function DmsSTR(ByVal vArg As Variant) As String DmsSTR = Dmis.DmsSTR(vArg) End Function Public Function DmsSUBSTR(ByVal str As String, ByVal x As Integer, Optional y As Variant) As String If Not IsMissing(y) Then DmsSUBSTR = Dmis.DmsSUBSTR(str, x, y) Else DmsSUBSTR = Dmis.DmsSUBSTR(str, x) End If End Function Public Function DmsVAL(ByVal str As String) As Double DmsVAL = Dmis.DmsVAL(str) End Function Public Function DmsEOF() End Function Public Function DmsEOLN() End Function Public Function DmsSDATE() As String DmsSDATE = Dmis.DmsSDATE End Function Public Function DmsSTIME() As String DmsSTIME = Dmis.DmsSTIME End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' BufferDump Function Calls for CADPath '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub FileStart(FileName As String, ModelName As String, PieceName As String) Dim sFile As String On Error Resume Next ' Assign the Global Variable g_sFileName = FileName g_sModelName = ModelName g_sPieceName = PieceName sFile = FileName & PieceName & ".DAT" CreatePath FileName Open sFile For Output As #9 Print #9, "$===========================" Print #9, "$ CADPath Data File " Print #9, "$===========================" Print #9, "$ Model: " & ModelName Print #9, "$ Piece: " & PieceName If objData.Inches = True Then Print #9, "$ Data Unit: " & "INCH" Else Print #9, "$ Data Unit: " & "MM" End If Print #9, "$ " Close #9 End Sub Sub FileEnd() On Error Resume Next Close #9 End Sub Sub BufferDump(Optional sFeatureName As String) Dim sFile As String Dim i As Integer Dim j As Integer Dim nFeatureType As Integer On Error Resume Next ' Use the default value nFeatureType = -1 If g_sFileName = "" Then FileStart "C:\CADPath", "Default", "DataFile" End If sFile = g_sFileName & g_sPieceName & ".DAT" Open sFile For Append As #9 If Not IsMissing(sFeatureName) Then If UCase(sFeatureName) <> "INTERNAL" Then Print #9, " " Print #9, "$ " Print #9, "$ CLOUD NAME: " & sFeatureName MLString "PR" Print #9, "$ PROBE RADIUS " & LTrim$(str(objData.S7 / 2)) MLString "RF " & sFeatureName nFeatureType = objData.S4 End If End If If nFeatureType = 1 Then MLString "RB " & sFeatureName j = objData.S7 If j = 1 Then BufferDumpPoint sFeatureName ElseIf j > 1 Then MLString "RB ALL" For i = 0 To j - 1 Print #9, FxDpFmt(objData.S9(i, 0), "#######.#######0"), FxDpFmt(objData.S9(i, 1), "#######.#######0"), FxDpFmt(objData.S9(i, 2), "#######.#######0") Next i Else ' No points available End If Else If Not IsMissing(sFeatureName) Then MLString "RB ALL," & sFeatureName Else MLString "RB ALL" End If j = objData.S7 For i = 0 To j - 1 Print #9, FxDpFmt(objData.S9(i, 0), "#######.#######0"), FxDpFmt(objData.S9(i, 1), "#######.#######0"), FxDpFmt(objData.S9(i, 2), "#######.#######0") Next i End If Print #9, "$ " Print #9, "$ END OF DATA " & sFeatureName Print #9, "$ " Close #9 End Sub Sub BufferDumpPoint(sFeatureName As String) Dim x As Double Dim y As Double Dim z As Double Dim rad As Double MLString "PR" rad = objData.S7 / 2 MLString "RF " & sFeatureName If objData.S4 <> 1 Then Exit Sub End If x = objData.s(2, 0) + rad * objData.s(14, 0) y = objData.s(3, 0) + rad * objData.s(15, 0) z = objData.s(4, 0) + rad * objData.s(16, 0) Print #9, FxDpFmt(x, "#######.#######0"), FxDpFmt(y, "#######.#######0"), FxDpFmt(z, "#######.#######0") End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' Functions to Support Datum Alignment ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' Method: '' ReadUserBuffer() As Variant '' Description: '' Read the user buffer and return the coordinate as one dimension array. '' Parameters: '' None '' Return Value: '' One dimemsion array containing the raw data stored in user summation '' array. The data sequence is x1,y1,z1,x2,y2,z2,...,xn,yn,zn. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function ReadUserBuffer() As Variant Dim vPointsArray As Variant Dim vTransform As Variant Dim i As Integer Dim j As Integer ' One Dimension Array of Size 54 = 6 * 3 * 3 Elements ' Data Storage Format ' N1( X, Y, Z ) Index 0 to 2 : Nominal Point ' V1( X, Y, Z ) Index 3 to 5 : Nominal Point VT Direction ' P1( X, Y, Z ) Index 6 to 8 : 1st Offset Measurement Point ' One Dimension Array of Size 90 = 6 * 5 * 3 Elements ' Data Storage Format ' N1( X, Y, Z ) Index 0 to 2 : Nominal Point ' P1( X, Y, Z ) Index 3 to 5 : Target Measurement Point ' P2( X, Y, Z ) Index 6 to 8 : 1st Offset Measurement Point ' P3( X, Y, Z ) Index 9 to 11 : 2rd Offset Measurement Point ' P4( X, Y, Z ) Index 12 to 14 : 3nd Offset Measurement Point ' Retrieve Data in User Summation Array MLString "RB ALL" j = objData.S7 If j = 0 Then Exit Function End If ReDim vPointsArray(j * 3 - 1) For i = 0 To j - 1 vPointsArray(i * 3 + 0) = objData.S9(i, 0) vPointsArray(i * 3 + 1) = objData.S9(i, 1) vPointsArray(i * 3 + 2) = objData.S9(i, 2) Next i ReadUserBuffer = vPointsArray End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' Method: '' TransformRefFrame(vTransf As Variant) '' Description: '' Transform current active reference frame '' Parameters: '' vTransf As Variant: A single dimension array of size 12 '' 0 to 2 : translation vector '' 3 to 5 : X Axis Orientation '' 6 to 8 : y Axis Orientation '' 9 to 11: Z Axis Orientation '' Return Value: '' None ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Sub TransformRefFrame(vTransf As Variant) If IsEmpty(vTransf) Then Exit Sub End If Dim sCmdStr As String Dim sCmdStr1 As String Dim sCmdStr2 As String ' Create Origin sCmdStr1 = FxDpFmt(vTransf(9), "#######.#######0") + "," + FxDpFmt(vTransf(10), "#######.#######0") + "," + FxDpFmt(vTransf(11), "#######.#######0") sCmdStr = "ST " + sCmdStr1 + ",1" MLString sCmdStr sCmdStr = "SF _CP_ORIGIN" MLString sCmdStr ' Create X-Y Plane sCmdStr1 = FxDpFmt(vTransf(9), "#######.#######0") + "," + FxDpFmt(vTransf(10), "#######.#######0") + "," + FxDpFmt(vTransf(11), "#######.#######0") sCmdStr2 = FxDpFmt(vTransf(6), "#######.#######0") + "," + FxDpFmt(vTransf(7), "#######.#######0") + "," + FxDpFmt(vTransf(8), "#######.#######0") sCmdStr = "ST " + sCmdStr1 + ",2," + sCmdStr2 MLString sCmdStr sCmdStr = "SF _CP_XY_PLN" MLString sCmdStr ' Create X Axis sCmdStr1 = FxDpFmt(vTransf(9), "#######.#######0") + "," + FxDpFmt(vTransf(10), "#######.#######0") + "," + FxDpFmt(vTransf(11), "#######.#######0") sCmdStr2 = FxDpFmt(vTransf(0), "#######.#######0") + "," + FxDpFmt(vTransf(1), "#######.#######0") + "," + FxDpFmt(vTransf(2), "#######.#######0") sCmdStr = "ST " + sCmdStr1 + ",3," + sCmdStr2 MLString sCmdStr sCmdStr = "SF _CP_X_AXIS" MLString sCmdStr ' SetXYZOrigin sCmdStr = "MX " + FxDpFmt(vTransf(9), "#######.#######0") MLString sCmdStr sCmdStr = "MY " + FxDpFmt(vTransf(10), "#######.#######0") MLString sCmdStr sCmdStr = "MZ " + FxDpFmt(vTransf(11), "#######.#######0") MLString sCmdStr ' Level to the XY plane sCmdStr = "XY" MLString sCmdStr sCmdStr = "LV OFF,_CP_XY_PLN" MLString sCmdStr ' Establish Offset sCmdStr = "EO X,+X,_CP_X_AXIS" MLString sCmdStr ' Cleanup sCmdStr = "DF _CP_ORIGIN" MLString sCmdStr sCmdStr = "DF _CP_X_AXIS" MLString sCmdStr sCmdStr = "DF _CP_XY_PLN" MLString sCmdStr End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' Method: '' DatumAlignment(nMinIter As Long, '' nMaxIter As Long, '' fTol As Double, '' nMethod as Long, '' hFunc As Long ) '' Description: '' DatumAlignment iteration control loop '' Parameters: '' nMinIter : Minimun Number of Iterations '' nMaxIter : Maximun Number of Iterations '' fTol : Tolerance iteration termination condition '' nMethod : Datum Alignment Method '' 1: Iterative Bestfit Method '' 2: Iterative 3-2-1 Method '' hFunc : The datum points measurement function passed by using '' AddressOf basic function. This is the CallBack function '' used by DatumAlignment '' Return Value: '' None ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Sub DatumAlignment(nMinIter As Long, nMaxIter As Long, fTol As Double, nMethod As Long, hFunc As Long) Dim objAlign As Object Dim vData As Variant Dim vRet As Variant Dim vTrans As Variant Dim vRMS As Variant Dim vDatumRes As Variant Dim vRadius As Double Dim nIter As Long Dim nPoints As Long Dim bStop As Boolean Dim nSize As Long Dim sCmdStr As String Dim i As Integer ' Create IQAlignment COM Object Set objAlign = CreateObject("IQAlignment.DatumAlign") If objAlign Is Nothing Then ' Warning Message End End If ' Set Current Working Units If objData.Inches = True Then objAlign.SetInch Else objAlign.SetMetric End If objAlign.Visible = True objAlign.SetFlowControlInfo nMinIter, nMaxIter, fTol MLString "PR" vRadius = objData.S7 / 2 ' Output Residue Error sCmdStr = "@ @" CrtData sCmdStr sCmdStr = "@ Iter# RMS " For i = 0 To 5 sCmdStr = sCmdStr + " " + "Point" + str(i + 1) + " " Next i sCmdStr = sCmdStr + "@" CrtData sCmdStr 'Iteration Control Loop nIter = 1 bStop = False Do ' Read in all the point in User Summation Array vData = ReadUserBuffer If IsEmpty(vData) Then GoTo END_DATUM_ALIGNMENT End If nSize = UBound(vData) - LBound(vData) + 1 If nMethod = 1 And nSize = 90 Then 'Iterative Bestfit Method nPoints = nSize / 3 ElseIf nMethod = 2 And nSize = 54 Then 'Iterative 3-2-1 Method nPoints = nSize / 3 Else GoTo END_DATUM_ALIGNMENT End If 'nMethod = 1 -> Using Datum to Plane fitting algorithm, the data points are not compendated 'nMethod = 2 -> Using 3-2-1 method, the data points are the compensated points, probe radius is not used. 'return code: 0 = succeeded, ' -1 = failed due to insufficient data ' -2 = failed due to too large residue ' -3 = failed due to invalid method ' -4 = failed due to invalid number of data points ' -5 = failed due to large alignment transformation vRet = objAlign.Align(vData, vRadius, nPoints, nMethod) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Get Alignment Results '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' vTrans = objAlign.GetTransform() vDatumRes = objAlign.GetResidue() vRMS = objAlign.GetRMS() ' Output Residue Error sCmdStr = "@ " + FxDpFmt(nIter, "0#") + " " + FxDpFmt(vRMS, "#.####0") For i = 0 To 5 sCmdStr = sCmdStr + " " + FxDpFmt(vDatumRes(i), "#.####0") + " " Next i sCmdStr = sCmdStr + "@" CrtData sCmdStr ' Check Return Value for Error Message If (vRet <> 0) Then GoTo END_DATUM_ALIGNMENT End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Transform Current Active Reference Frame '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' TransformRefFrame vTrans ' Update RR1 to Reflect the Change MLString "SR 1,@P.C.S.@" '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Termination Conditions '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If nIter >= nMaxIter Or vRMS < fTol Then bStop = True End If If nIter >= nMaxIter Then Dim Style, Response, Msg, Title Msg = " Maximun interation # is reached !!! " & Chr(13) & Chr(10) & Chr(13) & Chr(10) Msg = Msg + " Abort - Abort Part Program? " & Chr(13) & Chr(10) Msg = Msg + " Retry - Run One More Iteration?" & Chr(13) & Chr(10) Msg = Msg + " Ignore - Stop Iteration and Continue Part Program? " Title = "Datum Alignment" Response = MsgBox(Msg, vbAbortRetryIgnore, Title) ' End Part Program If Response = vbAbort Then bStop = True End ' Try One More Iteration ElseIf Response = vbRetry Then bStop = False 'Stop Iteration and Continue to Part Program Else bStop = True End If End If If nIter < nMinIter Then bStop = False End If If bStop = False Then objAlign.MeasureDatum hFunc nIter = nIter + 1 End If Loop Until bStop = True ' end of iteration control loop END_DATUM_ALIGNMENT: Set objAlign = Nothing End Sub ' This function is used in place of the VB Format command to generate a formatted ' number that always uses a period for a decimal point. Public Function FxDpFmt(v As Variant, sFmt As String) As String FxDpFmt = FixDP(Format(v, sFmt)) End Function ' This routine checks for an internationalized decimal point within the ' string sNum (expected to be a formatted number) and, if found, converts ' it to a standard decimal point. Public Function FixDP(sNum As String) As String Dim DecPt As String Dim N As Integer DecPt = CStr(-1.1) DecPt = Mid(DecPt, 3, 1) FixDP = sNum N = InStr(FixDP, DecPt) If N <> 0 Then Mid(FixDP, N, 1) = "." End Function Public Sub FF_CloseModel() Dim v As Variant If (Not oFF_Monitor.Available) Then Exit Sub ReDim v(1) v(0) = 3 v(1) = sFF_Model FF_Request v v = FF_Response sFF_Model = "" End Sub Public Sub FF_OpenDatFile(sDatFile As String) Dim v As Variant If (Not oFF_Monitor.Available) Then Exit Sub ReDim v(1) v(0) = 11 v(1) = sDatFile FF_Request v v = FF_Response If v(1) = 0 Then FF_Error End Sub Public Sub FF_OpenModel(sModel As String) Dim v As Variant If (Not oFF_Monitor.Available) Then Exit Sub sFF_Model = sModel ReDim v(1) v(0) = 2 v(1) = sModel FF_Request v v = FF_Response If v(1) = 0 Then FF_Error End Sub Public Sub FF_321Alignment(sFeature1 As String, sFeature2 As String, sPrompt As String) Dim v As Variant If (Not oFF_Monitor.Available) Then Exit Sub If sFeature2 = "" Then ReDim v(2) Else ReDim v(3) v(3) = sFeature2 End If v(0) = 8 v(1) = 1 v(2) = sFeature1 FF_Request v MLString "PM @" & sPrompt & "@" v = FF_Response If v(1) = 0 Then FF_Error End Sub Public Sub FF_3DCADAlignment() Dim v As Variant Dim i As Integer Dim j As Integer If (Not oFF_Monitor.Available) Then Exit Sub 'make FormFit visible ReDim v(1) v(0) = 0 v(1) = 1 FF_Request v v = FF_Response j = 1 '(UBound(vFF_CADPts) + 1) / 3 ReDim v(4) v(0) = 8 v(1) = 0 For i = 0 To UBound(vFF_CADPts) Step 3 v(2) = vFF_CADPts(i) v(3) = vFF_CADPts(i + 1) v(4) = vFF_CADPts(i + 2) FF_Request v MLString "QU @Take point " & Format(j, "###") & " on the part as prompted/highlighted by IQ-FormFit.@,$QU" v = FF_Response If v(1) = 0 Then FF_Error ReDim v(4) v(0) = 8 v(1) = 0 j = j + 1 '- 1 Next i End Sub Public Sub FF_FeatureAnalysis() Dim v As Variant If (Not oFF_Monitor.Available) Then Exit Sub FF_Request vFF_FeatureNames v = FF_Response If v(1) = 0 Then FF_Error End Sub Public Sub FF_Synchronize() Dim v As Variant Dim i As Integer If (Not oFF_Monitor.Available) Then Exit Sub If Not objData.MPOnline Then Exit Sub ReDim v(0) v(0) = 9 FF_Request v v = FF_Response If v(1) = 0 Then FF_Error Exit Sub End If iFF_SyncDirection = v(2) For i = 0 To 2 dFF_SyncXlation(i) = v(i + 3) Next i For i = 0 To 8 dFF_SyncRotation(i) = v(i + 6) Next i End Sub Public Sub FF_PartAnalysis(iType As Integer, iXformDir As Integer, iModRefFrame) Dim v As Variant Dim i As Integer If (Not oFF_Monitor.Available) Then Exit Sub ReDim v(3) v(0) = 6 v(1) = iType v(2) = iXformDir v(3) = iModRefFrame FF_Request v v = FF_Response If v(1) = 0 Then FF_Error Exit Sub End If iFF_AnalysisDirection = v(2) For i = 0 To 2 dFF_AnalysisXlation(i) = v(i + 3) Next i For i = 0 To 8 dFF_AnalysisRotation(i) = v(i + 6) Next i End Sub Public Sub FF_MiscData() Dim v As Variant If (Not oFF_Monitor.Available) Then Exit Sub MLString "GT" MLString "RI " & objData.s0d ReDim v(2) v(0) = 10 'Miscellaneous data v(1) = Abs(CInt(objData.Inches)) v(2) = objData.s11 'Probe radius FF_Request v v = FF_Response If v(1) = 0 Then FF_Error End Sub Public Sub FF_OutputData(iOutputBmp As Integer) Dim sName As String Dim v As Variant If (Not oFF_Monitor.Available) Then Exit Sub If iOutputBmp = 0 Then Exit Sub ReDim v(3) v(0) = 4 v(1) = iOutputBmp v(2) = "" v(3) = "" sName = MMTempDir & "\" & App.EXEName & Format(Now, "_ddMMMyy_hhmmssss") If iOutputBmp And &H8 Then sFF_BitmapFile = sName & ".bmp" v(2) = sFF_BitmapFile End If If iOutputBmp And &H4 Then sFF_SummaryDataFile = sName & ".dat" v(3) = sFF_SummaryDataFile End If FF_Request v v = FF_Response If v(1) = 0 Then FF_Error End Sub Private Function FF_Request(v As Variant) As Boolean On Error GoTo errTrap If (Not oFF_Monitor.Available) Then Exit Function iFF_RequestType = v(0) objCtx.MonitorEventPost 22, v FF_Request = True Exit Function errTrap: FF_Request = False End Function Private Function FF_Response() As Variant On Error GoTo errTrap If (Not oFF_Monitor.Available) Then Exit Function While Not oFF_Monitor.DataReady DoEvents Wend oFF_Monitor.DataReady = False FF_Response = oFF_Monitor.Data Exit Function errTrap: FF_Response = vbEmpty End Function Private Sub FF_Error() Dim v As Variant MsgBox "IQ-FormFit could not successfully complete request type " & iFF_RequestType & "." & _ vbCrLf & "Further interaction with IQ-FormFit is not possible.", vbOKOnly Or vbExclamation, _ "Error at FF_Error" ReDim v(0) v(0) = 1 'Abort the current request FF_Request v v = FF_Response oFF_Monitor.Available = False End Sub 'This routine will create a path to a file if it doesn't exist 'It assumes that the information to the right of the last '\' is a filename Public Sub CreatePath(sPath As String) Dim sTemp As String Dim iPos As Integer iPos = InStr(1, sPath, "\") While iPos > 0 sTemp = Left$(sPath, iPos - 1) If Not DirExists(sTemp) Then MkDir sTemp iPos = InStr(iPos + 1, sPath, "\") Wend Exit Sub End Sub Public Function DirExists(sFile As String) As Boolean Dim sName As String On Error GoTo errTrap If sFile = "" Then DirExists = False Exit Function End If sName = Dir$(sFile, vbDirectory) If Len(sName) > 0 Then If (GetAttr(sFile) And vbDirectory) = vbDirectory Then DirExists = True Else DirExists = False End If Else DirExists = False End If ' Force the Dir command to execute until it returns ' a blank string. If this is not done, WinNT will ' hold a lock open on the requested directory While Dir <> "" Wend Exit Function errTrap: DirExists = False Exit Function End Function Public Property Get TrapScanDeflectStatus() As Boolean TrapScanDeflectStatus = objData.TrapScanDeflectStatus End Property Public Property Let TrapScanDeflectStatus(bNewValue As Boolean) objData.TrapScanDeflectStatus = bNewValue End Property Public Property Get ScanDeflectStatus() As Integer ScanDeflectStatus = objData.ScanDeflectStatus End Property Public Property Let ScanDeflectStatus(iNewValue As Integer) objData.ScanDeflectStatus = iNewValue End Property